home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / CGIshell 1.3.2 / Pocket 6.5 / Extensions / Strings.pf < prev   
Text File  |  1995-11-11  |  5KB  |  129 lines
  1. ( Strings 10/15/95 23:30:19 )
  2. \ 
  3. \ These words deal with 0 terminated strings as in Ron Kneusel's CGIShell.
  4. \  <ftp://kreeft.intmed.mcw.edu/Q/pub/forth/cgishell.sit.hqx>
  5. \
  6. \ Several words in this set are borrowed from rtk's CGIShell, some renamed,
  7. \ some modified. The names maintain compatability with the word-set in
  8. \  _Library of Forth Routines and Utilities_  by  James D. Terry
  9. \  (c) 1986 Shadow Lawn Press  ISBN 0-452-25841-3
  10. \
  11. \ In comments, string is the starting address of a zero terminated string,
  12. \ and len is the length not including the zero. String[255] is a length
  13. \ byte preceded string, with a max length of 255 bytes.
  14. \
  15. \ String format:
  16. \ string address is first byte ->This is a string.0<- Ends with a zero
  17.  
  18. \ Length and $clear get used a lot - do them in ml.
  19. : LENGTH ( string -- len )  \ length of the string at addr
  20.  ( was:  dup >r BEGIN dup c@ WHILE 1+ REPEAT  r> - ; )
  21.     ,$ 3016          \     move (ps),d0
  22.     ,$ 4a33 ,$ 0000  \ @0: tst.b 0(bp,d0.w)
  23.     ,$ 6706          \     beq.s @1
  24.     ,$ 0640 ,$ 0001  \     addi #1,d0
  25.     ,$ 60f4          \     bra.s @0
  26.     ,$ 9056          \ @1: sub (ps),d0
  27.     ,$ 3c80 ;        \     move d0,(ps)
  28.  
  29. : $CLEAR  ( string -- ) \ erase a string ( equivalent to: 0 swap c! ; )
  30.    ,$ 301E  ,$ 4233 ,$ 0000 ;  \ move (ps)+,d0  clr.b 0(bp,d0.w)
  31.  
  32. \ The next 4 words are directly from Ron's CGI Framework.
  33.  
  34. \ Convert between null terminated and length byte preceeded type strings.
  35. : >NULL ( string[255] -- )  \ convert a string[255] into a string
  36.     dup c@ 2dup + >r swap dup 1+ swap rot cmove  r> $clear ;
  37.  
  38. : >COUNT ( string -- ) \ convert a string into a string[255]
  39.     dup length >r dup dup 1+ r cmove  r> swap c! ;  
  40.  
  41.  
  42. \ Terminal I/O.
  43. : 0TYPE ( string -- )  \ type null terminated string
  44.     dup length dup IF type ELSE 2drop THEN ;
  45.     
  46. : ACCEPT ( string len -- )  \ like expect but stores zero at end of line
  47.     2dup 1+ 0 fill  >r dup r> expect dup length 1- + $clear ; ( bug fixed)
  48.  
  49.  
  50. \ Test a string's content.
  51. : $= ( string1 string2 -- f ) \ true if string2,len2 = string1,len1
  52.     dup length 1+  -1 swap 2swap rot 0 DO  \ set flag to true
  53.       over r + c@  over r + c@  =         \  check each byte
  54.       0= IF rot 1+ rot rot leave THEN    \   change flag to false
  55.     LOOP 2drop ;
  56.  
  57.  
  58. \ Manipulate strings.
  59. : $COPY ( source.string dest.string -- ) \ copy source to dest
  60.     over length 1+ cmove ;
  61.  
  62. : $+ ( source.string dest.string -- ) \ append source to the end of dest
  63.     dup length + $copy ;
  64.  
  65. : $LEFT ( string len -- ) \ clip string to len chars
  66.     over length min  +  $clear ;
  67.  
  68. : $RIGHT ( string len -- ) \ clip string to rightmost len characters
  69.     over length over - 0> IF
  70.       over length over -  rot dup rot +  swap rot 1+  cmove
  71.     ELSE 2drop THEN ;
  72.  
  73. : $MID ( string start len -- ) \ clip string to len section at start
  74.     rot rot over length  swap - 1+  >r dup r> $right  swap $left ;
  75.  
  76. : $UPPER ( string -- ) dup >count  dup upper  dup >null drop ; \ uppercase
  77.  
  78.  
  79. \ Find and replace with strings.
  80. variable POS  ( local variable )
  81. : $FIND ( string1 string2 -- pos ) \ find string2 in string1; 0 if unfound
  82.     0 pos !
  83.     over length over length - 2+  1  DO
  84.       over here $copy
  85.       here  over length  r swap  $mid
  86.       here over
  87.       $= IF  r pos !  leave THEN
  88.     LOOP  2drop
  89.     pos @ ;
  90.  
  91. : $REPLACE ( dest.string1 find.string2 replace.string3 -- )
  92.     rot >r swap
  93.     r over $find ?dup IF  \   IF string2 is found in string1
  94.       r here $copy         \  THEN replace string2 with string3
  95.       r over 1-  $left      \  modify string1
  96.       rot r $+
  97.       swap length +           \        !!! IMPORTANT !!!
  98.       here length  swap - 1+   \   DOES NOT CHECK FOR OVERWRITE
  99.       here swap $right          \  String1 MUST accomodate any
  100.       here r> $+                 \ additional bytes from string3
  101.     ELSE 2drop r> drop  THEN ;
  102.  
  103. \ Create and assign strings of several varieties.
  104. : $CONSTANT  \ compiling: ( -- ) name a string terminated with '}'
  105.     CREATE  125 word here c@ 1+ dup 2 mod + allot  0 [compile] ,
  106.     DOES>  count drop ;  \ runtime action: ( -- string )
  107. \ This uses a curley brace because they aren't used much on web pages.
  108. \   eg:  $constant ESERROR Empty stack!}
  109.  
  110. : $VARIABLE CREATE 1+ allot ;  \ compiling: ( len -- ) name an empty string
  111. \   eg:  80 $variable INPUTLINE  inputline ${ Hi there!}
  112.  
  113. : $ARRAY \ create named string arrays - name from input stream
  114.     CREATE  dup ,  * allot    \ compiling: ( number_of_.strings len -- )
  115.     DOES>  dup @ rot * + 2+ ;  \ runtime: ( string_number -- string )
  116. \   eg:  15 64 $array ERRORMESSAGES
  117. \        0 errorMessages ${ Error!}
  118.  
  119. \ NOTE: Constants and variables are identical except that constants
  120. \       have no room to grow, but variables _may_ have extra memory
  121. \       allotted to them to grow into.  Also constants are assigned
  122. \       when they are created, while variables (and arrays, which are
  123. \       lists of variables) must be assigned seperately (see below).
  124.  
  125. : ${ ( string -- ) \ assign text to a string from the input stream.
  126.     125 word  here >null  here swap $copy ;
  127. \   eg:  inputLine ${ Something to say!}    *** NO OVERWRITE CHECK ***
  128.  
  129.